home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / inf_vector.t < prev    next >
Text File  |  1988-05-02  |  5KB  |  110 lines
  1. (herald infinite_vector)
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. (define (make-infinite-vector start-size init . maybe-id)
  27.   (let ((start-size (enforce nonnegative-fixnum? start-size)))
  28.     (receive (vec size)
  29.              (expand-vector nil 0 start-size init)
  30.       (let ((id (if maybe-id (car maybe-id) nil))
  31.             (expand (lambda (index)
  32.                       (let ((index (enforce nonnegative-fixnum? index)))
  33.                         (receive (new-vec new-size)
  34.                                  (expand-vector vec size (fx+ 1 index) init)
  35.                           (set vec new-vec)
  36.                           (set size new-size))))))
  37.         (object (lambda (index)
  38.                   (if (fx>= index size) (expand index))
  39.                   (vref vec index))
  40.           ((setter self) 
  41.            (lambda (index new)
  42.              (if (fx>= index size) (expand index))
  43.              (set (vref vec index) new)))
  44.           ((recycle self)
  45.            (return-vector vec)
  46.            (set vec nil)       ;Safety
  47.            (set size -1))      ;
  48.           ((identification self) id)
  49.           ((set-identification self new-id)
  50.            (set id new-id))
  51.           ((print-type-string self) "infinite vector"))))))
  52.  
  53. (define (expand-vector vec size index init)
  54.   (let* ((new-vec (obtain-from-pool (vector-pool index)))
  55.          (new-size (vector-length new-vec)))
  56.     (cond (vec
  57.            (vector-replace new-vec vec size)
  58.            (return-vector vec)))
  59.     (let ((init (if init init (lambda (x) (ignore x) 0))))
  60.       (do ((i size (fx+ i 1)))
  61.           ((fx>= i new-size))
  62.         (set (vref new-vec i) (init i))))
  63.     (return new-vec new-size)))
  64.  
  65. ;;; Stolen from TABLE
  66.  
  67. ;++ is there another way to do this?  Should an error be returned
  68. ;++ is a vector is larger then the maximum size?
  69. ;;; Vector sizes are currently of the form 2**n
  70. ;;; There are 16 pools, for vectors of various sizes.
  71. ;;;    0  1  2  3   4   5   6    7    8    9   10    11    12 ...
  72. ;;;    8 16 32 64 128 256 512 1024 2048 4096 8192 16384 32768 ...
  73.  
  74. (define-constant *minimum-vector-size* 8)
  75. (define-constant *minimum-vector-bits*
  76.   (fx- (fixnum-howlong *minimum-vector-size*) 1))
  77. (define-constant *number-of-vector-pools* 16)
  78.  
  79. (define *vector-pools*
  80.   (make-vector *number-of-vector-pools*))
  81.  
  82. (define (initialize-vector-pool)
  83.   (do ((i 0 (fx+ i 1))
  84.        (size *minimum-vector-size* (fixnum-ashl size 1)))
  85.       ((fx>= i *number-of-vector-pools*) t)
  86.     (set (vref *vector-pools* i)
  87.          (make-pool `(*vector-pool* ,i)
  88.                     (lambda () (make-vector size))
  89.                     1
  90.                     vector?))))
  91.  
  92. (define (vector-pool size)
  93.   (let ((i (fx- (fixnum-howlong (fx- size 1))
  94.                 *minimum-vector-bits*)))
  95.     (cond ((or (fx= 0 size)
  96.                (fx>= 0 i))
  97.            (vref *vector-pools* 0))
  98.           ((fx< i 15)
  99.            (vref *vector-pools* i))
  100.           (else
  101.            (error "expanding vector size exceeds implementation maximum")))))
  102.  
  103. ;;; Return a vector to the appropriate pool.
  104.  
  105. (define (return-vector vec)
  106.   (let ((vec (enforce vector? vec)))
  107.     (return-to-pool (vector-pool (vector-length vec)) vec)))
  108.  
  109. (initialize-vector-pool)
  110.